home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / gsdbloo.exe / GS_DBL.PAS < prev    next >
Pascal/Delphi Source File  |  1992-02-28  |  12KB  |  360 lines
  1. {------------------------------------------------------------------------------
  2.                            Floating Point Formatting
  3.  
  4.        GS_DBL Copyright (c)  Richard F. Griffin
  5.  
  6.        16 February 1992
  7.  
  8.        102 Molded Stone Pl
  9.        Warner Robins, GA  31088
  10.  
  11.        -------------------------------------------------------------
  12.        This unit handles the routines to create and compare floating
  13.        point type doubles used in dBase indexes.  These routines save
  14.        10K of memory over the $N,E option for numeric coprocessor emulation.
  15.  
  16.        This unit will also convert from double to string.  This is done
  17.        by first converting from double to real and then using the Str
  18.        procedure.  Because of this, there may be inaccuracies for numbers
  19.        greater than 10-11 digits.
  20.  
  21.        dBase III indexes use type double to store all numeric and date
  22.        field keys.
  23.  
  24.        changes:
  25.  
  26. ------------------------------------------------------------------------------}
  27.  
  28. unit GS_Dbl;
  29. interface
  30. {$D-}
  31.  
  32. type
  33.  
  34. {-----------------------------------------------------------------------------
  35.    gsDouble type simulates IEEE double precision type.
  36.    Memory layout is:
  37.  
  38.                                  gsDouble Bytes
  39.         ┌────────┬────────┬────────┬───┴────┬────────┬────────┬───────────┐
  40.        [7]      [6]      [5]      [4]      [3]      [2]      [1]      [0]
  41.     76543210 76543210 76543210 76543210 76543210 76543210 76543210 76543210
  42.     seeeeeee│eeeemmmm│mmmmmmmm│mmmmmmmm│mmmmmmmm│mmmmmmmm│mmmmmmmm│mmmmmmmm
  43.     │└┴┴┴┴┴┴─┴┴┴┘└┴┴┴─┴┴┴┴┴┴┴┴─┴┴┴┴┴┴┴┴─┴┴┴┴┴┴┴┴─┴┴┴┴┴┴┴┴─┴┴┴┴┴┴┴┴─┴┴┴┴┴┴┴┘
  44.     │  Exponent                        Mantissa
  45.     └─ Sign
  46.  
  47.     Note the value is stored opposite from its representation; that is, the
  48.     sign/(MSB exponent) byte is stored in gsDouble[7].  The next byte, with
  49.     the (LSB exponent)/ (MSB Mantissa) is gsDouble[6]; and so on.....
  50.  
  51. -----------------------------------------------------------------------------}
  52.  
  53.    gsDouble    = array[0..7] of byte;
  54.  
  55.  
  56. function CmprDouble(var v1, v2) : integer;
  57. procedure MakeDouble(C_String: string;var dtype: gsDouble;var rcode : integer);
  58. function CnvrtDouble(var dtype) : string;
  59.  
  60. implementation
  61.  
  62. const
  63.    MaxNibble     = 64;
  64.    MaxBcdNibble  = 20;
  65.    EndNibble     = 63;
  66.  
  67. var
  68.    Index         : integer;
  69.    DecPlaces     : integer;
  70.    TotPlaces     : integer;
  71.    RndgFlag      : boolean;
  72.    InDecimals    : boolean;
  73.    InExponent    : boolean;
  74.    PositiveNum   : boolean;
  75.    PositiveExp   : boolean;
  76.  
  77.    Mantissa      : array[0..MaxNibble] of byte;
  78.    Exponent      : array[1..3] of byte;
  79.    DecExponent   : integer;
  80.  
  81.    BinExponent   : longint;
  82.    GrtrZero      : boolean;
  83.    DumpBit       : byte;
  84.  
  85.    rmdr,
  86.    LSp,
  87.    i             : integer;
  88.  
  89.    DblAry        : array[1..16] of byte;
  90.    DblWrk        : gsDouble;
  91.  
  92. function CmprDouble(var v1, v2) : integer;
  93. var
  94.    val1     : gsDouble absolute v1;
  95.    val2     : gsDouble absolute v2;
  96.    val1neg,
  97.    val2neg  : boolean;
  98.    flg      : boolean;
  99.    rslt     : integer;
  100.    loop     : integer;
  101. begin
  102.    val1neg := val1[7] > 127;
  103.    val2neg := val2[7] > 127;
  104.    flg := val1neg = val2neg;
  105.    if not flg then
  106.    begin
  107.       if val1neg then CmprDouble := -1 else CmprDouble := 1;
  108.       exit;
  109.    end;
  110.    loop := 7;
  111.    rslt := 0;
  112.    while (rslt = 0) and (loop >= 0) do
  113.    begin
  114.       if val1[loop] < val2[loop] then rslt := -1
  115.          else if val1[loop] > val2[loop] then rslt := 1;
  116.       loop:= loop-1;
  117.    end;
  118.    if val1neg then rslt := rslt*(-1);
  119.    CmprDouble := rslt;
  120. end;
  121.  
  122. procedure MakeDouble(C_String: string;var dtype: gsDouble;var rcode : integer);
  123.  
  124.    procedure AdjustMantissa;
  125.    begin
  126.       if DecExponent < 0 then
  127.       begin
  128.          while DecExponent < 0 do
  129.          begin
  130.             while Mantissa[1] = 0 do
  131.             begin
  132.                move(Mantissa[2], Mantissa[1], EndNibble);
  133.                dec(BinExponent,4);
  134.             end;
  135.             for i := 1 to pred(EndNibble) do
  136.             begin
  137.                Mantissa[succ(i)] := Mantissa[succ(i)] +
  138.                                     ((Mantissa[i] mod 10) * 16);
  139.                Mantissa[i] := Mantissa[i] div 10;
  140.             end;
  141.             Mantissa[EndNibble] := Mantissa[EndNibble] div 10;
  142.             inc(DecExponent);
  143.          end;
  144.       end
  145.       else
  146.                          {test for exponent > 0}
  147.          if DecExponent > 0 then
  148.          begin
  149.             while DecExponent > 0 do
  150.             begin
  151.                if Mantissa[1] <> 0 then
  152.                begin
  153.                   rmdr := Mantissa[EndNibble];
  154.                   move(Mantissa[1], Mantissa[2], pred(EndNibble));
  155.                   Mantissa[1] := 0;
  156.                   inc(BinExponent,4);
  157.                   if rmdr > 7 then
  158.                   begin
  159.                      inc(Mantissa[EndNibble]);
  160.                      i := EndNibble;
  161.                      while Mantissa[i] > 15 do
  162.                      begin
  163.                         Mantissa[i] := Mantissa[i] and $0F;
  164.                         dec(i);
  165.                         inc(Mantissa[i]);
  166.                      end;
  167.                   end;
  168.                end;
  169.                Mantissa[EndNibble] :=  (Mantissa[EndNibble] * 10);
  170.                for i := pred(EndNibble) downto 1 do
  171.                begin
  172.                   Mantissa[i] := (Mantissa[i] * 10) +
  173.                                  (Mantissa[succ(i)] shr 4);
  174.                   Mantissa[succ(i)] :=
  175.                                   Mantissa[succ(i)] and $0F;
  176.                end;
  177.                dec(DecExponent);
  178.             end;
  179.          end;
  180.    end;
  181.  
  182.  
  183.  
  184. begin
  185.    rcode := 0;
  186.    PositiveNum := true;
  187.    PositiveExp := true;
  188.    DecPlaces := 0;
  189.    DecExponent := 0;
  190.    RndgFlag  := true;
  191.    InDecimals := false;
  192.    InExponent := false;
  193.    FillChar(Mantissa,MaxNibble+1,#0);
  194.    FillChar(Exponent,3,#0);
  195.    if C_String <> '' then
  196.    begin
  197.       LSp := 1;
  198.       while (C_String[LSp] = ' ') and (LSp <= ord(C_String[0])) do
  199.          LSp := LSp+1;
  200.       for Index := LSp to length(C_String) do
  201.       begin
  202.          case C_String[Index] of
  203.  
  204.          '+'      : if InExponent then PositiveExp := true
  205.                        else PositiveNum := true;
  206.  
  207.          '-'      : if InExponent then PositiveExp := false
  208.                        else PositiveNum := false;
  209.  
  210.          '0'..'9' : begin
  211.                        if InDecimals then inc(DecPlaces);
  212.                        if InExponent then
  213.                        begin
  214.                           DecExponent := (DecExponent * 10) +
  215.                                          byte(C_String[Index]) and $0F;
  216.                        end
  217.                        else
  218.                        begin
  219.                           if Mantissa[1] = 0 then
  220.                           begin
  221.                              Mantissa[EndNibble] :=
  222.                                              (Mantissa[EndNibble] * 10) +
  223.                                              (byte(C_String[Index]) and $0F);
  224.                              for i := pred(EndNibble) downto 1 do
  225.                              begin
  226.                                 Mantissa[i] := (Mantissa[i] * 10) +
  227.                                                (Mantissa[succ(i)] shr 4);
  228.                                 Mantissa[succ(i)] :=
  229.                                                 Mantissa[succ(i)] and $0F;
  230.                              end;
  231.                           end
  232.                           else
  233.                           begin
  234.                              if RndgFlag then
  235.                              begin
  236.                                 RndgFlag := false;
  237.                                 if C_String[Index] > '4' then
  238.                                                      inc(Mantissa[EndNibble]);
  239.                              end;
  240.                              if not InDecimals then dec(DecPlaces);
  241.                           end;
  242.                        end;
  243.                     end;
  244.  
  245.  
  246.          '.'      : InDecimals := true;
  247.  
  248.          'e',
  249.          'E'      : begin
  250.